Visual Basic Source Code

home *** CD-ROM | disk | FTP | other *** search

/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / financ1a / moneymat.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1999-10-13 | 40.6 KB | 1,107 lines

VERSION 5.00 Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX" Begin VB.Form frmMoneyMath BorderStyle = 1 'Fixed Single Caption = "Financial Reckoner" ClientHeight = 6360 ClientLeft = 45 ClientTop = 330 ClientWidth = 7740 ForeColor = &H00C0C0C0& Icon = "MoneyMath.frx":0000 LinkTopic = "Form2" LockControls = -1 'True MaxButton = 0 'False MinButton = 0 'False ScaleHeight = 6360 ScaleWidth = 7740 Begin VB.Frame Frame2 Caption = "Answer" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 2385 Left = 4020 TabIndex = 11 Top = 3840 Width = 3525 Begin VB.PictureBox Picture2 Height = 405 Left = 1080 ScaleHeight = 345 ScaleWidth = 375 TabIndex = 18 Top = 210 Width = 435 Begin VB.CommandButton cmdClear BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 345 Left = -30 Picture = "MoneyMath.frx":030A Style = 1 'Graphical TabIndex = 19 TabStop = 0 'False ToolTipText = "Clear" Top = 0 Width = 405 End End Begin VB.PictureBox Picture1 Height = 405 Left = 420 ScaleHeight = 345 ScaleWidth = 375 TabIndex = 14 Top = 210 Width = 435 Begin VB.CommandButton cmdAnswer BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 345 Left = -30 Picture = "MoneyMath.frx":035F Style = 1 'Graphical TabIndex = 15 TabStop = 0 'False ToolTipText = "Compute answer" Top = 0 Width = 405 End End Begin VB.TextBox txtAnswer Alignment = 1 'Right Justify BackColor = &H80000018& BeginProperty DataFormat Type = 1 Format = """$""#,##0.00" HaveTrueFalseNull= 0 FirstDayOfWeek = 0 FirstWeekOfYear = 0 LCID = 1033 SubFormatType = 2 EndProperty BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 345 Left = 2220 Locked = -1 'True TabIndex = 12 TabStop = 0 'False Text = "0" Top = 1950 Width = 1155 End Begin VB.Label lblAnswerNote Caption = "lblAnswerNote" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 675 Left = 90 TabIndex = 20 Top = 750 Width = 3285 End Begin VB.Label lblAnswer Caption = "lblAnswer" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 405 Left = 90 TabIndex = 13 Top = 1530 Width = 3285 End End Begin VB.Frame Frame1 Caption = "Actual data" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 2385 Left = 180 TabIndex = 7 Top = 3840 Width = 3615 Begin VB.TextBox Text4 Alignment = 1 'Right Justify BackColor = &H80000018& BeginProperty DataFormat Type = 1 Format = """$""#,##0.00" HaveTrueFalseNull= 0 FirstDayOfWeek = 0 FirstWeekOfYear = 0 LCID = 1033 SubFormatType = 2 EndProperty Height = 345 Left = 2550 TabIndex = 3 Text = "0" Top = 1830 Width = 825 End Begin VB.TextBox Text3 Alignment = 1 'Right Justify BackColor = &H80000018& BeginProperty DataFormat Type = 1 Format = """$""#,##0.00" HaveTrueFalseNull= 0 FirstDayOfWeek = 0 FirstWeekOfYear = 0 LCID = 1033 SubFormatType = 2 EndProperty Height = 345 Left = 2550 TabIndex = 2 Text = "0" Top = 1350 Width = 825 End Begin VB.TextBox Text1 Alignment = 1 'Right Justify BackColor = &H80000018& BeginProperty DataFormat Type = 1 Format = """$""#,##0.00" HaveTrueFalseNull= 0 FirstDayOfWeek = 0 FirstWeekOfYear = 0 LCID = 1033 SubFormatType = 2 EndProperty Height = 345 Left = 2550 TabIndex = 0 Text = "0" Top = 390 Width = 825 End Begin VB.TextBox Text2 Alignment = 1 'Right Justify BackColor = &H80000018& BeginProperty DataFormat Type = 1 Format = """$""#,##0.00" HaveTrueFalseNull= 0 FirstDayOfWeek = 0 FirstWeekOfYear = 0 LCID = 1033 SubFormatType = 2 EndProperty Height = 345 Left = 2550 TabIndex = 1 Text = "0" Top = 870 Width = 825 End Begin VB.Label Label4 Caption = "Label4" Height = 525 Left = 210 TabIndex = 17 Top = 1830 Width = 2175 End Begin VB.Label Label3 Caption = "Label3" Height = 435 Left = 210 TabIndex = 10 Top = 1380 Width = 2145 End Begin VB.Label Label1 Caption = "Label1" Height = 405 Left = 210 TabIndex = 9 Top = 420 Width = 2145 End Begin VB.Label Label2 Caption = "Label2" Height = 285 Left = 210 TabIndex = 8 Top = 900 Width = 2175 End End Begin VB.ComboBox cboRef BackColor = &H80000018& BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 315 Left = 1920 Style = 2 'Dropdown List TabIndex = 6 TabStop = 0 'False Top = 3390 Width = 795 End Begin RichTextLib.RichTextBox rtbHypothesis Height = 2535 Left = 180 TabIndex = 5 TabStop = 0 'False Top = 720 Width = 7395 _ExtentX = 13044 _ExtentY = 4471 _Version = 393217 BackColor = -2147483624 HideSelection = 0 'False ReadOnly = -1 'True ScrollBars = 2 Appearance = 0 TextRTF = $"MoneyMath.frx":03B6 BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty End Begin VB.Label lblScenario Caption = "Scenario" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 600 TabIndex = 21 Top = 390 Width = 1035 End Begin VB.Image Image1 Height = 480 Left = 90 Picture = "MoneyMath.frx":048D Top = 30 Width = 480 End Begin VB.Label lblScenarioRef Caption = "Scenario Ref No." BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 240 TabIndex = 16 Top = 3420 Width = 1545 End Begin VB.Label lblInstruction Caption = "To select, click on any part of a scenario text, or select its Ref No., then key in actual data." ForeColor = &H00000080& Height = 315 Left = 600 TabIndex = 4 Top = 90 Width = 6675 End Attribute VB_Name = "frmMoneyMath" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False ' MoneyMath.frm ' By Herman Liu ' This code concerns money, nothing else but money. It is written to serve as a ' ready Financial Reckoner of many facets. To avoid involving dry and complicated ' terms and jargons, it just presents different models of financial scenarios, ' e.g. interest rate, instalment amount, loan, investment, mortgage and annuity, ' etc. You choose any of them, key in your actual data and the computed answer ' is right there. An equally important utility is, it allows you to vary your ' data as many times and to any extent you may want, so as to test the sensitivity ' to the result of a change of certain variable(s), and/or to compare the impact ' between changes. [Notes: 1. Readers who are not interested in money at all, ' nor in its mathematics, may still want to take a look as this program also shows ' some interesting programming techniques. 2. If old hands out there (e.g. ACMA/ ' /FCMA, CA/CPA or mathematicians) spot any discrepancy in my formula and approach ' at the background in each situation, would you please let me know.] Option Explicit Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _ (ByVal hwnd As Long, ByVal wMsg As Long, wParam As Long, lParam As Any) As Long Const EM_CHARFROMPOS& = &HD7 Private Type POINTAPI X As Long y As Long End Type Dim testFlag1 As Boolean Dim testFlag2 As Boolean Dim SuspendFlag As Boolean Dim arrT(10) As String Private Sub Form_Load() FillText ClearAll cboRef.Clear Dim i For i = 0 To UBound(arrT) cboRef.AddItem i + 1 Next i cboRef.ListIndex = 0 rtbHypothesis.MousePointer = vbIconPointer SuspendFlag = False End Sub Private Sub FillText() Dim t As String t = "[1] There had been a delay in settling your credit card statement of $1,500 last" & vbCrLf t = t & " month. This results in this month's statement showing an interest charge of" & vbCrLf t = t & " $40. At what interest rate you are being charged?" & vbCrLf _ & vbCrLf arrT(0) = t t = "[2] You wish to purchase at the price of $10,000 a paper which will mature in" & vbCrLf t = t & " 30 days for $10,065. The bank manager tells you that the interest accrued" & vbCrLf t = t & " thereof is 8.0% p.a. Can you verify what the bank manager says?" & vbCrLf & vbCrLf arrT(1) = t t = "[3] How much to pay for the purchase of a Bill with a maturity amount of" & vbCrLf t = t & " $11,000 in 35 days, when the applicable interest rate is 7.0% p.a.?" & vbCrLf _ & vbCrLf arrT(2) = t t = "[4] A car with a cash price of $25,000 is to be paid for by (1) a down payment" & vbCrLf t = t & " of $5,000 and (2) 60 monthly instalment payments of $450 each, starting" & vbCrLf t = t & " 30 days thereafter . What is the interest rate charged?" & vbCrLf _ & vbCrLf arrT(3) = t t = "[5] A mortgage of $100,000 to be cleared by 144 equal monthly payments," & vbCrLf t = t & " starting after 30 days of signing. At an average interest rate of 8% p.a.," & vbCrLf t = t & " what should be the amount of each payment?" & vbCrLf & vbCrLf arrT(4) = t t = "[6] A mortgage of $150,000 to be cleared by 132 equal monthly payments of" & vbCrLf t = t & " $1,800 each, starting after 30 days of signing. What is the interest rate" & vbCrLf t = t & " implied in the calculation?" & vbCrLf & vbCrLf arrT(5) = t t = "[7] A mortgage of $130,000 to be cleared by 156 equal monthly payments of" & vbCrLf t = t & " $1,650 each. You have the option, which must be exercised after the 24th" & vbCrLf t = t & " payment and before the last 24 payments, to discharge whatever the balance" & vbCrLf t = t & " of loan in full without incurring any penalty. After 38 payments, you decide to" & vbCrLf t = t & " exercise the option: (A) What are the principal and interest amounts paid so" & vbCrLf t = t & " far and (B) How much do you have to pay for the remaining balance?" & vbCrLf & vbCrLf arrT(6) = t t = "[8] What is the present worth of $10,000 due after 5 years, taking into account" & vbCrLf t = t & " of an average interest rate of 8.0% p.a. compounded semi-annually?" & vbCrLf _ & vbCrLf arrT(7) = t t = "[9] You put $5,000 into an account at the beginning of every year for 5 years." & vbCrLf t = t & " How much would the account balance be at the end of 5 years if the" & vbCrLf t = t & " agreed interest rate is 6.0% p.a. compounded quarterly?" & vbCrLf _ & vbCrLf arrT(8) = t t = "[10] You plan to have an annuity which will enable you to draw $10,000 every" & vbCrLf t = t & " year for 15 years, starting one year from now. Given an interest rate of" & vbCrLf t = t & " 6.0% p.a., what should be the amount of the annuity?" & vbCrLf & vbCrLf arrT(9) = t t = "[11] An annuity which will enable you to draw an amount each year for 15 years," & vbCrLf t = t & " starting one year from now. The amount of first year is $10,000 and each" & vbCrLf t = t & " subsequent year a 10% increase over the previous one. At an interest of" & vbCrLf t = t & " 6.0% p.a., what is the present worth of this annuity?" & vbCrLf arrT(10) = t rtbHypothesis.Text = arrT(0) & arrT(1) & arrT(2) & arrT(3) & arrT(4) & arrT(5) & arrT(6) & arrT(7) _ & arrT(8) & arrT(9) & arrT(10) End Sub Private Sub ClearAll() Label1.Caption = "" Label2.Caption = "" Label3.Caption = "" Label4.Caption = "" Text1.Text = 0 Text2.Text = 0 Text3.Text = 0 Text4.Text = 0 Text1.Visible = False Text2.Visible = False Text3.Visible = False Text4.Visible = False lblAnswerNote.Caption = "" lblAnswerNote.Visible = False lblAnswer.Caption = "" lblAnswer.Visible = False txtAnswer.Text = 0 txtAnswer.Visible = False End Sub Private Sub rtbHypothesis_MouseUp(Button As Integer, Shift As Integer, X As Single, y As Single) SuspendFlag = True ClearAll HighlightRef1 X, y SuspendFlag = False GetDataInput Text1.SetFocus End Sub Private Sub Text1_KeyPress(KeyAscii As Integer) FilterAmountKey KeyAscii End Sub Private Sub Text2_KeyPress(KeyAscii As Integer) FilterAmountKey KeyAscii End Sub Private Sub Text3_KeyPress(KeyAscii As Integer) FilterAmountKey KeyAscii End Sub Private Sub Text4_KeyPress(KeyAscii As Integer) FilterAmountKey KeyAscii End Sub Private Sub txtAnswer_KeyPress(KeyAscii As Integer) FilterAmountKey KeyAscii End Sub Private Sub HighlightRef1(X As Single, y As Single) Dim pt As POINTAPI Dim chrPos As Integer Dim startPos As Integer Dim ch As String Dim txt As String Dim n As String ' Convert screen pos to pixels. pt.X = X \ Screen.TwipsPerPixelX pt.y = y \ Screen.TwipsPerPixelY chrPos = SendMessage(rtbHypothesis.hwnd, EM_CHARFROMPOS, 0, pt) If chrPos <= 0 Then Exit Sub End If txt = rtbHypothesis.Text If "]" <> Mid(txt, chrPos + 2, 1) Then For startPos = chrPos To 1 Step -1 ch = Mid(txt, startPos, 1) If ch = "[" Then Exit For ElseIf ch = "?" Then rtbHypothesis.SelLength = 0 Exit Sub End If Next startPos Else startPos = chrPos End If ' Ref is the char(s) after startPos ch = Mid(txt, startPos + 2, 1) If ch = "]" Then n = Val(Mid(txt, startPos + 1, 1)) Else n = Val(Mid(txt, startPos + 1, 2)) End If ' Synchronize value in cboRef cboRef.ListIndex = n - 1 rtbHypothesis.SelStart = startPos - 1 rtbHypothesis.SelLength = Len(Trim(arrT(Val(n - 1)))) - 1 End Sub Private Sub HighlightRef2(inRef As String) Dim startPos As Integer Dim txt As String txt = rtbHypothesis.Text startPos = InStr(txt, "[" & inRef & "]") If startPos = 0 Then Exit Sub End If If startPos > 0 Then rtbHypothesis.SelStart = startPos - 1 Else rtbHypothesis.SelStart = startPos - 1 End If rtbHypothesis.SelLength = Len(Trim(arrT(Val(inRef) - 1))) - 1 End Sub Private Sub cboRef_Click() If SuspendFlag Then Exit Sub End If ClearAll GetDataInput HighlightRef2 cboRef.Text End Sub Private Sub GetDataInput() Select Case cboRef.ListIndex Case 0 Label1 = "Payment delayed: $" Label2 = "Interest amount: $" Text1.Visible = True Text2.Visible = True lblAnswer.Caption = "Effective interest rate at (% p.a.)" Case 1 Label1 = "Price: $" Label2 = "No of days" Label3 = "Amount on maturity: $" Text1.Visible = True Text2.Visible = True Text3.Visible = True ' Invisible still; fix its value first lblAnswer.Caption = "Ordinary interest rate (% p.a.)" Case 2 Label1 = "Amount on maturity: $" Label2 = "No. of days" Label3 = "Interest at % p.a." Text1.Visible = True Text2.Visible = True Text3.Visible = True lblAnswer.Caption = "Purchase price should be ($)" Case 3 Label1 = "Cash price less down pmt: $" Label2 = "Total No. of pmt" Label3 = "Amount of each pmt: $" Text1.Visible = True Text2.Visible = True Text3.Visible = True lblAnswer.Caption = "Interest rate (% p.a.)" Case 4 Label1 = "Mortgage amount: $" Label2 = "Total No. of pmt" Label3 = "Interest at % p.a." Text1.Visible = True Text2.Visible = True Text3.Visible = True lblAnswer.Caption = "Each instalment is ($)" Case 5 Label1 = "Mortgage amount: $" Label2 = "Total No. of pmt" Label3 = "Monthly pmt: $" Text1.Visible = True Text2.Visible = True Text3.Visible = True lblAnswer.Caption = "Interest rate implied (% p.a)" Case 6 Label1 = "Mortgage amount: $" Label2 = "Total No. of pmt" Label3 = "Amount each pmt: $" Label4 = "Option after No. of pmt" Text1.Visible = True Text2.Visible = True Text3.Visible = True Text4.Visible = True lblAnswer.Caption = "B: Ignoring diff due to rounding, balance to be" & _ " paid is ($):" Case 7 Label1 = "Amount" Label2 = "Due No. of years from now" Label3 = "Interest % p.a." Label4 = "Interest computed: time(s) in year" Text4.Text = 2 ' Give default Text1.Visible = True Text2.Visible = True Text3.Visible = True Text4.Visible = True lblAnswer.Caption = "Present worth is ($)" Case 8 Label1 = "Yearly deposit: $" Label2 = "No. of years" Label3 = "Interest at % p.a." Label4 = "Interest computed: time(s) in year" Text4.Text = 4 ' Give default Text1.Visible = True Text2.Visible = True Text3.Visible = True Text4.Visible = True lblAnswer.Caption = "Account balance should be ($)" Case 9 Label1 = "Yearly draw: $" Label2 = "No. of years" Label3 = "Interest % p.a." Text1.Visible = True Text2.Visible = True Text3.Visible = True lblAnswer.Caption = "Value of annuity now is ($)" Case 10 Label1 = "Amount of first draw: $" Label2 = "Increment over prev year: %" Label3 = "No. of years" Label4 = "Interest % p.a." Text1.Visible = True Text2.Visible = True Text3.Visible = True Text4.Visible = True lblAnswer.Caption = "Present worth of annuity ($)" End Select End Sub Private Sub cmdClear_click() ClearAll cboRef.Text = cboRef.List(cboRef.ListIndex) Text1.SetFocus End Sub Private Sub cmdAnswer_Click() On Error GoTo errHandler If Text1.Visible Then If Val(Format(Text1.Text)) = 0 Then MsgBox "Cannot have zero value" Text1.SetFocus Exit Sub Else If IsAmountEntry(Text1.Text) = False Then MsgBox "Invalid entry" Text1.SetFocus Exit Sub End If End If End If If Text2.Visible Then If Val(Format(Text2.Text)) = 0 Then MsgBox "Cannot have zero value" Text2.SetFocus Exit Sub Else If IsAmountEntry(Text2.Text) = False Then MsgBox "Invalid entry" Text2.SetFocus Exit Sub End If End If End If If Text3.Visible Then If Val(Format(Text3.Text)) = 0 Then MsgBox "Cannot have zero value" Text3.SetFocus Exit Sub Else If IsAmountEntry(Text3.Text) = False Then MsgBox "Invalid entry" Text3.SetFocus Exit Sub End If End If End If If Text4.Visible Then If Val(Format(Text4.Text)) = 0 Then MsgBox "Cannot have zero value" Text4.SetFocus Exit Sub Else If IsAmountEntry(Text4.Text) = False Then MsgBox "Invalid entry" Text4.SetFocus Exit Sub End If End If End If Dim i, a, p, r, q, y, n, f, t, ct, X Select Case cboRef.ListIndex Case 0 p = Val(Text1.Text) f = Val(Text2.Text) X = (f * 12 / p) * 100 If X < 0 Then MsgBox "Invalid/illogical input data" Exit Sub End If txtAnswer.Text = Format(X, "##,##0.00") Case 1 p = Val(Text1.Text) ' Price of paper n = Val(Text2.Text) ' No. of days a = Val(Text3.Text) ' Maturity value X = ((a - p) / p * (365 / n)) * 100 If X < 0 Then MsgBox "Invalid/illogical input data" Exit Sub End If lblAnswerNote.Caption = "(If basing on 365 days, exact interest rate is " & _ Format(X, "##,##0.00") & "% p.a.)" lblAnswerNote.Visible = True X = ((a - p) / p * (360 / n)) * 100 txtAnswer.Text = Format(X, "##,##0.00") Case 2 a = Val(Text1.Text) n = Val(Text2.Text) / 100 r = Val(Text3.Text) X = a / (1 + (r * n / 365)) If X < 0 Then MsgBox "Invalid/illogical input data" Exit Sub End If txtAnswer.Text = Format(X, "##,##0") Case 3 p = Val(Text1.Text) ' Cash price less downpayment n = Val(Text2.Text) ' Total No. of pmts a = Val(Text3.Text) ' Amount of each pmt r = ((2 * 12 * ((a * n) - p)) / (p * (n + 1))) * 100 '---------------------------------------------------- ' Traditionally the rate quoted would have been as above ' basing on the generally accepted conventional method of ' computation. '---------------------------------------------------- ' But now we can test and refine it '---------------------------------------------------- testFlag1 = False testFlag2 = False r = r / 12 / 100 Screen.MousePointer = vbHourglass Refine_Case3: q = p For i = 1 To n ' Loop through total No. of pmts X = q * (1 + r) - a q = X Next i If X > 0 Then If testFlag2 = False Then If (r - 0.00001) > 0 Then testFlag1 = True r = r - 0.00001 GoTo Refine_Case3 End If End If ElseIf X < 0 Then If testFlag1 = False Then testFlag2 = True r = r + 0.00001 GoTo Refine_Case3 End If End If ' Convert r back to "per year" X = r * 12 * 100 Screen.MousePointer = vbDefault If X < 0 Then MsgBox "Invalid/illogical input data" Exit Sub ElseIf X > 99 Then MsgBox "Invalid/illogical input data" Exit Sub End If txtAnswer.Text = Format(X, "##,##0.00") Case 4 p = Val(Text1.Text) ' Mortgage amount n = Val(Text2.Text) ' Total No. of pmts r = Val(Text3.Text) ' Interest rate '---------------------------------------------------- ' Conventional method uses 2 below; this is not an absolute. ' The figure of "12" is used below as there are 12 payments ' in a year. '---------------------------------------------------- r = r / 100 X = (((p * (n + 1) * r / (2 * 12)) + p)) / n '---------------------------------- ' The above conventional method had been used in the past when ' computer was not commonly available, nowadays we should apply ' a better approach to arrive at an more accurate answer. '---------------------------------- ' The amount of payment should be such that after discharging ' last payment there is zero balance. Test it and refine it if ' required '---------------------------------- testFlag1 = False testFlag2 = False r = r / 12 Screen.MousePointer = vbHourglass Refine_Case4: q = p For i = 1 To n ' Loop through total No. of pmts t = q * (1 + r) - X q = t Next i If t > 0 Then If testFlag2 = False Then testFlag1 = True X = X + 1 GoTo Refine_Case4 End If ElseIf t < 0 Then If testFlag1 = False Then If (X - 1) > 0 Then testFlag2 = True X = X - 1 GoTo Refine_Case4 End If End If End If Screen.MousePointer = vbDefault If X < 0 Then MsgBox "Invalid/illogical input data" Exit Sub End If txtAnswer.Text = Format(X, "##,##0") Case 5 p = Val(Text1.Text) ' Mortgage amount n = Val(Text2.Text) ' Total No. of pmts a = Val(Text3.Text) ' Each pmt t = a * n - p r = (2 * 12 * t) / (p * (n + 1)) testFlag1 = False testFlag2 = False r = r / 12 Screen.MousePointer = vbHourglass Refine_Case5: q = p For i = 1 To n ' Loop through total No. of pmts X = q * (1 + r) - a q = X Next i If X > 0 Then If testFlag2 = False Then If (r - 0.00001) > 0 Then testFlag1 = True r = r - 0.00001 GoTo Refine_Case5 End If End If ElseIf X < 0 Then If testFlag1 = False Then testFlag2 = True r = r + 0.00001 GoTo Refine_Case5 End If End If ' Convert r back to "per year", and "%", for display X = (r * 12) * 100 Screen.MousePointer = vbDefault If X < 0 Then MsgBox "Invalid/illogical input data" Exit Sub End If txtAnswer.Text = Format(X, "##,##0.00") Case 6 p = Val(Text1.Text) ' Mortgage amount n = Val(Text2.Text) ' Total No. of pmts a = Val(Text3.Text) ' Each pmt f = Val(Text4.Text) ' To exercise option after No. of pmts If n < 49 Then If f <> n Then MsgBox "No option possible in this case" Exit Sub End If End If If f < 24 Then MsgBox "Can exercise the option after at least 24 pmts" Text4.SetFocus Exit Sub ElseIf f > (n - 24) Then MsgBox "Cannot exercise the option during last 24 pmts" Text4.SetFocus Exit Sub End If t = a * n - p ' Total interest amount ' Calculate interest rate, preliminarily r = (2 * 12 * t) / (p * (n + 1)) ' No "* 100" ' Convert to "per month" r = r / 12 ' hence no "/ 100" If r < 0 Then MsgBox "Invalid/illogical input data" Exit Sub End If testFlag1 = False testFlag2 = False Screen.MousePointer = vbHourglass Refine_Case6: q = p For i = 1 To n X = q * (1 + r) - a q = X Next i If X > 0 Then If testFlag2 = False Then ' Try to reduce interest rate If (r - 0.00001) > 0 Then testFlag1 = True r = r - 0.00001 GoTo Refine_Case6 End If End If ElseIf X < 0 Then If testFlag1 = False Then testFlag2 = True ' Try to increase interest rate r = r + 0.00001 GoTo Refine_Case6 End If End If '---------------------------------- ' Continue after above testing '---------------------------------- t = 0 ct = 0 q = p For i = 1 To f t = q * r ' Interest ct = ct + t ' Cumulated interest X = q * (1 + r) - a q = X Next i lblAnswerNote.Caption = "A: Of total payment of $" & Format(a * f, "##,##0") & _ " paid so far: $" & Format(ct, "###,###,##0") & " is interest portion," & _ " $" & Format(a * f - ct, "###,###,##0") & " is principal portion." lblAnswerNote.Visible = True ' We better not to use X directly, as there is likely to be an ' accumulated rounding diff which may cause it to differ from ' the figure of p-(a*f-ct) txtAnswer.Text = Format(p - (a * f - ct), "##,##0") Screen.MousePointer = vbDefault Case 7 a = Val(Text1.Text) y = Val(Text2.Text) r = Val(Text3.Text) q = Val(Text4.Text) r = r / 100 X = a / (((1 + r / q)) ^ (y * q)) If X < 0 Then MsgBox "Invalid/illogical input data" Exit Sub End If txtAnswer.Text = Format(X, "##,##0") Case 8 f = Val(Text1.Text) y = Val(Text2.Text) r = Val(Text3.Text) q = Val(Text4.Text) r = r / 100 X = (f * ((1 + r / q) ^ (y * q) - 1)) _ / (((1 + (r / q)) ^ q) - 1) If X < 0 Then MsgBox "Invalid/illogical input data" Exit Sub End If txtAnswer.Text = Format(X, "##,##0") Case 9 f = Val(Text1.Text) ' Yearly draw y = Val(Text2.Text) ' No. of years r = Val(Text3.Text) ' Interest rate r = r / 100 X = f * ((1 - (1 / ((1 + r) ^ y))) / r) If X < 0 Then MsgBox "Invalid/illogical input data" Exit Sub End If txtAnswer.Text = Format(X, "##,##0") Case 10 f = Val(Text1.Text) ' Yearly draw q = Val(Text2.Text) ' % increment each year y = Val(Text3.Text) ' No. of years r = Val(Text4.Text) ' Interest rate ' Same as above r = r / 100 X = f * ((1 - (1 / ((1 + r) ^ y))) / r) ' Above plus increments in years after the first year X = X + (X / 15) * (1 + q / 100) ^ (y - 1) If X < 0 Then MsgBox "Invalid/illogical input data" Exit Sub End If txtAnswer.Text = Format(X, "##,##0") End Select lblAnswer.Visible = True txtAnswer.Visible = True Exit Sub errHandler: MsgBox "Error occurred, cannot yield a valid answer" End Sub Sub FilterAmountKey(mInKey) If mInKey < Asc("0") Or mInKey > Asc("9") Then If mInKey <> 32 And mInKey <> 8 Then 'Allow Space & Backspace If mInKey <> Asc(".") Then ' Allow decimal mInKey = 0 ' Cancel the typed in character End If End If End If End Sub Function IsAmountEntry(txt As String) As Boolean Dim ch As String Dim i As Integer, j As Integer IsAmountEntry = False If Len(LTrim(RTrim(txt))) = 0 Then Exit Function End If j = 0 For i = 1 To Len(txt) ch = Mid$(txt, i, 1) If ch < "0" Or ch > "9" Then If ch <> "." Then Exit Function Else j = j + 1 End If End If Next i If j > 1 Then Exit Function End If IsAmountEntry = True End Function